home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / bipl.zip / PROGS.ZIP / LISP.ICN < prev    next >
Lisp/Scheme  |  1992-09-28  |  10KB  |  416 lines
  1. ############################################################################
  2. #
  3. #    File:     lisp.icn
  4. #
  5. #    Subject:  Program to interpret LISP programs
  6. #
  7. #    Author:   Stephen B. Wampler, modified by Phillip Lee Thomas
  8. #
  9. #    Date:     February 4, 1991
  10. #
  11. ###########################################################################
  12. #
  13. #     This program is a simple interpreter for pure Lisp. It takes the
  14. #  name of the Lisp program as a command-line argument.
  15. #
  16. #     The syntax and semantics are based on EV-LISP, as described in
  17. #  Laurent Siklossy's "Let's Talk LISP" (Prentice-Hall, 1976, ISBN
  18. #  0-13-532762-8).  Functions that have been predefined match those
  19. #  described in Chapters 1-4 of the book.
  20. #
  21. #     No attempt at improving efficiency has been made, this is
  22. #  rather an example of how a simple LISP interpreter might be
  23. #  implemented in Icon.
  24. #
  25. #     The language implemented is case-insensitive.
  26. #
  27. #     It only reads enough input lines at one time to produce at least
  28. #   one LISP-expression, but continues to read input until a valid
  29. #   LISP-expression is found.
  30. #
  31. #     Errors:
  32. #
  33. #        Fails on EOF; fails with error message if current
  34. #     input cannot be made into a valid LISP-expression (i.e. more
  35. #     right than left parens).
  36. #
  37. ############################################################################
  38. #
  39. #  Syntax:
  40. #    (quote (a b c))           ==> (A B C)
  41. #    (setq a (quote (A B C)))  ==> (A B C)
  42. #    (car a)                   ==> (A)
  43. #    (cdr a)                   ==> (B C)
  44. #    (cons (quote d) a)        ==> (D A B C)
  45. #    (eq (car a) (car a))      ==> T
  46. #    (atom (quote ()))         ==> T
  47. #    (atom a)                  ==> NIL
  48. #    (null (car (car a)))      ==> T
  49. #    (eval (quote a))          ==> (A B C)
  50. #    (print a)                 ==> (A B C)
  51. #                                  (A B C)
  52. #    (define (quote (
  53. #            (cadr (quote (lambda (l) (car (cdr l)))))
  54. #            (cddr (quote (lambda (l) (cdr (cdr l)))))
  55. #            )))               ==> (CADR CDDR)
  56. #    (trace (quote (cadr)))    ==> NIL
  57. #    (untrace (quote (cadr)))  ==> NIL
  58. #    (itraceon)                ==> T [turns on icon tracing]
  59. #    (itraceoff)               ==> NIL [turns off icon tracing]
  60. #    (exit)                    ==> [exit gracefully from icon]
  61. #
  62. ############################################################################
  63.  
  64. global words,     # table of variable atoms
  65.        T, NIL,    # universal constants
  66.        infile     # command line library files
  67.  
  68. global trace_set  # set of currently traced functions
  69.  
  70. record prop(v,f)  # abbreviated propery list
  71.  
  72. ### main interpretive loop
  73. #
  74. procedure main(f) 
  75. local sexpr, source
  76.    initialize()
  77.    while infile := open(source := (pop(f) | "CON")) do {
  78.       write("Reading: ", source)
  79.       every sexpr := bstol(getbs()) do  {
  80.             PRINT([EVAL([sexpr])])
  81.             writes("> ")
  82.             }
  83.       }
  84.  
  85. end
  86.  
  87. ## (EVAL e) - the actual LISP interpreter
  88. #
  89. procedure EVAL(l)
  90. local fn, arglist, arg
  91.    l := l[1]
  92.    if T === ATOM([l]) then {                 # it's an atom
  93.       if T === l then return .T
  94.       if EQ([NIL,l]) === T then return .NIL
  95.       return .((\words[l]).v | NIL)
  96.       }
  97.    if glist(l) then {                        # it's a list
  98.       if T === ATOM([l[1]]) then
  99.          case l[1] of {
  100.          "QUOTE" : return .(l[2] | NIL)
  101.          "COND"  : return COND(l[2:0])
  102.          "SETQ"  : return SET([l[2]]|||evlis(l[3:0]))
  103.          "ITRACEON"  : return (&trace := -1,T)
  104.          "ITRACEOFF" : return (&trace := 0,NIL)
  105.          "EXIT"      : exit(0)
  106.          default : return apply([l[1]]|||evlis(l[2:0])) | NIL
  107.          }
  108.       return apply([EVAL([l[1]])]|||evlis(l[2:0])) | NIL
  109.       }
  110.    return .NIL
  111. end
  112.  
  113. ## apply(fn,args) - evaluate the function
  114.  
  115. procedure apply(l)
  116. local fn, arglist, arg, value, fcn
  117.    fn := l[1]
  118.    if member(trace_set, string(fn)) then {
  119.       write("Arguments of ",fn)
  120.       PRINT(l[2:0])
  121.       }
  122.    if value := case string(fn) of {
  123.       "CAR"     : CAR([l[2]]) | NIL
  124.       "CDR"     : CDR([l[2]]) | NIL
  125.       "CONS"    : CONS(l[2:0]) | NIL
  126.       "ATOM"    : ATOM([l[2]]) | NIL
  127.       "NULL"    : NULL([l[2]]) | NIL
  128.       "EQ"      : EQ([l[2],l[3]]) | NIL
  129.       "PRINT"   : PRINT([l[2]]) | NIL
  130.       "EVAL"    : EVAL([l[2]]) | NIL
  131.       "DEFINE"  : DEFINE(l[2]) | NIL
  132.       "TRACE"   : TRACE(l[2]) | NIL
  133.       "UNTRACE" : UNTRACE(l[2]) | NIL
  134.       } then {
  135.          if member(trace_set, string(fn)) then {
  136.             write("value of ",fn)
  137.             PRINT(value)
  138.             }
  139.          return value
  140.          }
  141.    fcn := (\words[fn]).f | return NIL
  142.    if type(fcn) == "list" then
  143.       if fcn[1] == "LAMBDA" then {
  144.          value :=  lambda(l[2:0],fcn[2],fcn[3])
  145.          if member(trace_set, string(fn)) then {
  146.             write("value of ",fn)
  147.             PRINT(value)
  148.             }
  149.          return value
  150.          }
  151.       else
  152.          return EVAL([fn])
  153.    return NIL
  154. end
  155.  
  156. ## evlis(l) - evaluate everything in a list
  157. #
  158. procedure evlis(l)
  159. local arglist, arg
  160.    arglist := []
  161.    every arg := !l do
  162.       put(arglist,EVAL([arg])) | fail
  163.    return arglist
  164. end
  165.  
  166.  
  167. ### Initializations
  168.  
  169. ## initialize() - set up global values
  170. #
  171. procedure initialize()
  172.    words := table()
  173.    trace_set := set()
  174.    T     := "T"
  175.    NIL   := []
  176. end
  177.  
  178. ### Primitive Functions
  179.  
  180. ## (CAR l)
  181. #
  182. procedure CAR(l)
  183.    return glist(l[1])[1] | NIL
  184. end
  185.  
  186. ## (CDR l)
  187. #
  188. procedure CDR(l)
  189.    return glist(l[1])[2:0] | NIL
  190. end
  191.  
  192. ## (CONS l)
  193. #
  194. procedure CONS(l)
  195.    return ([l[1]]|||glist(l[2])) | NIL
  196. end
  197.  
  198. ## (SET a l)
  199. #
  200. procedure SET(l)
  201.    (T === ATOM([l[1]])& l[2]) | return NIL
  202.    /words[l[1]] := prop()
  203.    if type(l[2]) == "prop" then
  204.       return .(words[l[1]].v := l[2].v)
  205.    else
  206.       return .(words[l[1]].v := l[2])
  207. end
  208.  
  209. ## (ATOM a)
  210. #
  211. procedure ATOM(l)
  212.    if type(l[1]) == "list" then
  213.       return (*l[1] = 0 & T) | NIL
  214.    return T
  215. end
  216.  
  217. ## (NULL l)
  218. #
  219. procedure NULL(l)
  220.    return EQ([NIL,l[1]])
  221. end
  222.  
  223. ## (EQ a1 a2)
  224. #
  225. procedure EQ(l)
  226.    if type(l[1]) == type(l[2]) == "list" then
  227.       return (0 = *l[1] = *l[2] & T) | NIL
  228.    return (l[1] === l[2] & T) | NIL
  229. end
  230.  
  231. ## (PRINT l)
  232. #
  233. procedure PRINT(l)
  234.    if type(l[1]) == "prop" then
  235.       return PRINT([l[1].v])
  236.    return write(strip(ltos(l)))
  237. end
  238.  
  239. ## COND(l) - support routine to eval
  240. #                 (for COND)
  241. procedure COND(l)
  242. local pair
  243.    every pair := !l do {
  244.       if type(pair) ~== "list" |
  245.               *pair ~= 2 then {
  246.          write(&errout,"COND: ill-formed pair list")
  247.          return NIL
  248.          }
  249.       if T === EVAL([pair[1]]) then
  250.          return EVAL([pair[2]])
  251.       }
  252.    return NIL
  253. end
  254.  
  255. ## (TRACE l)
  256. #
  257. procedure TRACE(l)
  258.    local fn
  259.  
  260.    every fn := !l do {
  261.       insert(trace_set, fn)
  262.       }
  263.    return NIL
  264. end
  265.  
  266. ## (UNTRACE l)
  267. #
  268. procedure UNTRACE(l)
  269.    local fn
  270.  
  271.    every fn := !l do {
  272.       delete(trace_set, fn)
  273.       }
  274.    return NIL
  275. end
  276.  
  277. ## glist(l) - verify that l is a list
  278. #
  279. procedure glist(l)
  280.    if type(l) == "list" then return l
  281. end
  282.  
  283. ## (DEFINE fname definition)
  284. #
  285. # This has been considerable rewritten (and made more difficult to use!)
  286. #  in order to match EV-LISP syntax.
  287. procedure DEFINE(l)
  288.    local fn_def, fn_list
  289.  
  290.    fn_list := []
  291.    every fn_def := !l do {
  292.       put(fn_list, define_fn(fn_def))
  293.       }
  294.  
  295.    return fn_list
  296. end
  297.  
  298. ## Define a single function (called by 'DEFINE')
  299. #
  300. procedure define_fn(fn_def)
  301.    /words[fn_def[1]] := prop(NIL)
  302.    words[fn_def[1]].f := fn_def[2]
  303.    return fn_def[1]
  304. end
  305.  
  306. ## lambda(actuals,formals,def)
  307. #
  308. procedure lambda(actuals, formals, def)
  309. local save, act, form, pair, result, arg, i
  310.    save := table()
  311.    every arg := !formals do
  312.       save[arg] := \words[arg] | prop(NIL)
  313.    i := 0
  314.    every words[!formals] := (prop(actuals[i+:=1]|NIL)\1)
  315.    result := EVAL([def])
  316.    every pair := !sort(save) do
  317.       words[pair[1]] := pair[2]
  318.    return result
  319. end
  320.  
  321. #  Date: June 10, 1988
  322. #
  323. procedure getbs()
  324. static tmp
  325.    initial tmp := ("" ~== |Map(read(infile))) || " "
  326.  
  327.    repeat {
  328.       while not checkbal(tmp) do {
  329.          if more(')','(',tmp) then break
  330.          tmp ||:= (("" ~== |Map(read(infile))) || " ") | break
  331.          }
  332.       suspend balstr(tmp)
  333.       tmp := (("" ~== |Map(read(infile))) || " ") | fail
  334.       }
  335. end
  336.  
  337. ## checkbal(s) - quick check to see if s is
  338. #       balanced w.r.t. parentheses
  339. #
  340. procedure checkbal(s)
  341.    return (s ? 1(tab(bal()),pos(-1)))
  342. end
  343.  
  344. ## more(c1,c2,s) - succeeds if any prefix of
  345. #       s has more characters in c1 than
  346. #       characters in c2, fails otherwise
  347. #
  348. procedure more(c1,c2,s)
  349. local cnt
  350.    cnt := 0
  351.    s ? while (cnt <= 0) & not pos(0) do {
  352.          (any(c1) & cnt +:= 1) |
  353.          (any(c2) & cnt -:= 1)
  354.          move(1)
  355.          }
  356.    return cnt >= 0
  357. end
  358.  
  359. ## balstr(s) - generate the balanced disjoint substrings
  360. #               in s, with blanks or tabs separating words
  361. #
  362. #       errors:
  363. #          fails when next substring cannot be balanced
  364. #
  365. #
  366. procedure balstr(s)
  367. static blanks
  368.    initial blanks := ' \t'
  369.    (s||" ") ? repeat {
  370.           tab(many(blanks))
  371.           if pos(0) then break
  372.           suspend (tab(bal(blanks))\1 |
  373.                   {write(&errout,"ill-formed expression")
  374.                     fail}
  375.                   ) \ 1
  376.           }
  377. end
  378.  
  379. ## bstol(s) - convert a balanced string into equivalent
  380. #       list representation.
  381. #
  382. procedure bstol(s)
  383. static blanks
  384. local l
  385.    initial blanks := ' \t'
  386.    (s||" ") ? {tab(many(blanks))
  387.                l := if not ="(" then s else []
  388.               }
  389.    if not string(l) then
  390.       every put(l,bstol(balstr(strip(s))))
  391.    return l
  392. end
  393.  
  394. ## ltos(l) - convert a list back into a string
  395. #
  396. #
  397. procedure ltos(l)
  398.    local tmp
  399.  
  400.    if type(l) ~== "list" then return l
  401.    if *l = 0 then return "NIL"
  402.    tmp := "("
  403.    every tmp ||:= ltos(!l) || " "
  404.    tmp[-1] := ")"
  405.    return tmp
  406. end
  407.  
  408. procedure strip(s)
  409.    s ?:= 2(="(", tab(bal()), =")", pos(0))
  410.    return s
  411. end
  412.  
  413. procedure Map(s)
  414.    return map(s, &lcase, &ucase)
  415. end
  416.